home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue57 / DragDrop / DragImageU.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-03-23  |  4.1 KB  |  154 lines
  1. unit DragImageU;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   StdCtrls, ExtCtrls;
  8.  
  9. type
  10.   //Delphi 4 and later allows us to inherit custom drag objects from 
  11.   //TDragControlObject (earlier versions forced you to go back to TDragObject)
  12.   TTextDragObject = class(TDragControlObject)
  13.   private
  14.     FDragImages: TDragImageList;
  15.   protected
  16.     function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; override;
  17.     function GetDragImages: TDragImageList; override;
  18.   public
  19.     Data: String;
  20.     destructor Destroy; override;
  21.   end;
  22.  
  23.   TForm1 = class(TForm)
  24.     Panel1: TPanel;
  25.     ListBox1: TListBox;
  26.     Label1: TLabel;
  27.     procedure FormCreate(Sender: TObject);
  28.     procedure Label1StartDrag(Sender: TObject; var DragObject: TDragObject);
  29.     procedure ListBox1StartDrag(Sender: TObject;
  30.       var DragObject: TDragObject);
  31.     procedure SharedEndDrag(Sender, Target: TObject; X, Y: Integer);
  32.     procedure Panel1DragOver(Sender, Source: TObject; X, Y: Integer;
  33.       State: TDragState; var Accept: Boolean);
  34.     procedure Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
  35.   private
  36.     FDragObject: TTextDragObject;
  37.   end;
  38.  
  39. var
  40.   Form1: TForm1;
  41.  
  42. const
  43.   crPacMan = 1; { Use values bigger than 0 }
  44.  
  45. implementation
  46.  
  47. {$R *.DFM}
  48.  
  49. {$R PacCur32.Res}
  50.  
  51. { TTextDragObject }
  52.  
  53. destructor TTextDragObject.Destroy;
  54. begin
  55.   FDragImages.Free;
  56.   inherited;
  57. end;
  58.  
  59. function TTextDragObject.GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor;
  60. begin
  61.   if Accepted then
  62.     Result := crPacMan
  63.   else
  64.     Result := inherited GetDragCursor(Accepted, X, Y)
  65. end;
  66.  
  67. function TTextDragObject.GetDragImages: TDragImageList;
  68. var
  69.   Bmp: TBitmap;
  70.   Txt: String;
  71. begin
  72.   if not Assigned(FDragImages) then
  73.     FDragImages := TDragImageList.Create(nil);
  74.   Result := FDragImages;
  75.   Result.Clear;
  76.   Bmp := TBitmap.Create;
  77.   try
  78.     //Make up some string to write on bitmap
  79.     Txt := Format('      The control called %s says "%s" at %s',
  80.       [Control.Name, Data, FormatDateTime('h:nn am/pm', Time)]);
  81.     Bmp.Canvas.Font.Name := 'Arial';
  82.     Bmp.Canvas.Font.Style := Bmp.Canvas.Font.Style + [fsItalic];
  83.     Bmp.Height := Bmp.Canvas.TextHeight(Txt);
  84.     Bmp.Width := Bmp.Canvas.TextWidth(Txt);
  85.     //Fill background with olive
  86.     Bmp.Canvas.Brush.Color := clOlive;
  87.     Bmp.Canvas.FloodFill(0, 0, clWhite, fsSurface);
  88.     //Write a string on bitmap
  89.     Bmp.Canvas.TextOut(0, 0, Txt);
  90.     Result.Width := Bmp.Width;
  91.     Result.Height := Bmp.Height;
  92.     //Make olive pixels transparent, whilst adding bmp to list
  93.     Result.AddMasked(Bmp, clOlive)
  94.   finally
  95.     Bmp.Free;
  96.   end
  97. end;
  98.  
  99. { TForm1 }
  100.  
  101. procedure FixControlStyles(Parent: TControl);
  102. var
  103.   I: Integer;
  104. begin
  105.   Parent.ControlStyle := Parent.ControlStyle + [csDisplayDragImage];
  106.   if Parent is TWinControl then
  107.     with TWinControl(Parent) do
  108.       for I := 0 to ControlCount - 1 do
  109.         FixControlStyles(Controls[I]);
  110. end;
  111.  
  112. procedure TForm1.FormCreate(Sender: TObject);
  113. begin
  114.   Screen.Cursors[crPacMan] := LoadCursor(HInstance, 'PacMan');
  115.   FixControlStyles(Self)
  116. end;
  117.  
  118. procedure TForm1.Label1StartDrag(Sender: TObject;
  119.   var DragObject: TDragObject);
  120. begin
  121.   FDragObject := TTextDragObject.Create(Sender as TLabel);
  122.   FDragObject.Data := TLabel(Sender).Caption;
  123.   DragObject := FDragObject;
  124. end;
  125.  
  126. procedure TForm1.ListBox1StartDrag(Sender: TObject;
  127.   var DragObject: TDragObject);
  128. begin
  129.   FDragObject := TTextDragObject.Create(Sender as TListBox);
  130.   with TListBox(Sender) do
  131.     FDragObject.Data := Items[ItemIndex];
  132.   DragObject := FDragObject;
  133. end;
  134.  
  135. procedure TForm1.SharedEndDrag(Sender, Target: TObject; X, Y: Integer);
  136. begin
  137.   //All draggable controls share this event handler
  138.   FDragObject.Free;
  139.   FDragObject := nil
  140. end;
  141.  
  142. procedure TForm1.Panel1DragOver(Sender, Source: TObject; X, Y: Integer;
  143.   State: TDragState; var Accept: Boolean);
  144. begin
  145.   Accept := Source is TTextDragObject
  146. end;
  147.  
  148. procedure TForm1.Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
  149. begin
  150.   (Sender as TPanel).Caption := TTextDragObject(Source).Data
  151. end;
  152.  
  153. end.
  154.